-- ----- BEGIN LICENSE BLOCK -----
-- Version: BSD
--
-- Copyright (c) 2016, Filip Brcic <brcha@gna.org>. All rights reserved.
--
-- ♡ 2017, fr33domlover <fr33domlover@riseup.net>.
-- Copying is an act of love. Please copy and share!
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--  * Redistributions of source code must retain the above copyright notice,
--    this list of conditions and the following disclaimer.
--
--  * Redistributions in binary form must reproduce the above copyright notice,
--    this list of conditions and the following disclaimer in the documentation
--    and/or other materials provided with the distribution.
--
--  * The name of the copyright holder may not be used to endorse or promote
--    products derived from this software without specific prior written
--    permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER "AS IS" AND ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
-- EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY DIRECT, INDIRECT,
-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
-- OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-- ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--
-- ----- END LICENSE BLOCK -----

-- | This package provides SASS support for Shakespeare and Yesod. It can
-- handle 4 types of files, which you can freely mix and use together in one
-- project:
--
-- * Plain SASS files, with file extension @sass@
-- * Plain SCSS files, with file extension @scss@
-- * Silius files, i.e. SASS with Shakespeare splices, extension @silius@
-- * Scarus files, i.e. SCSS with Shakespeare splices, extension @scarus@
--
-- Note that in Silius and Scarus files, the syntax for Haskell variable
-- interpolation is @%{}@, and not the @#{}@ that Shakespeare uses, because the
-- latter is syntax already used by SASS itself, which would cause a conflict.
module Text.Shakespeare.Sass
    ( wsass'
    , wfsSass
    ) where

import Control.Monad (when)
import Control.Monad.Trans.Maybe
import Crypto.Hash (hashWith)
import Crypto.Hash.Algorithms (SHA1 (SHA1))
import Data.Bool (bool)
import Data.Foldable (traverse_, for_, asum)
import Data.IORef
import Data.Maybe (isNothing)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (addDependentFile)
import System.Directory
import System.FilePath
import Text.Internal.Css (topLevelsToCassius)
import Text.Lucius (parseTopLevels)
import Text.ParserCombinators.Parsec hiding (Parser)
import Text.Sass
import Text.Shakespeare
import Yesod.Default.Util (WidgetFileSettings, TemplateLanguage (..)
                          ,defaultTemplateLanguages, wfsLanguages)
import Yesod.Core

import qualified Data.ByteString.Char8 as BC (pack, unpack, null)
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.UTF8 as BU

-- Copied from shakespeare because the function isn't exported
parse' ::  GenParser tok [a1] a -> SourceName -> [tok] -> Either ParseError a
parse' p = runParser p []

-- Copied from shakespeare because the function isn't exported
luciusFromString :: String -> Q Exp
luciusFromString s =
    topLevelsToCassius
  $ either (error . show) id $ parse parseTopLevels s s

data PieceType = PieceRaw | PieceVar | PieceUrl | PieceUrlParam | PieceMixin

data Piece = Piece PieceType String

-------------------------------------------------------------------------------
-- The is code below that parses the sass source to find interpolations, it's
-- based on the code from shakeapeare. I prefer to reuse than copy, but parsec
-- doesn't have a 'match' function like attoparsec does, and without it reuse
-- becomes ugly. So, just copying. The shakespeare internal code and API is a
-- mess anyway.
-------------------------------------------------------------------------------

parseCurlyBrackets :: Parser String
parseCurlyBrackets = between (char '{') (char '}') $ many $ noneOf "}\r\n"

parseVar :: Char -> Parser Piece
parseVar c = do
    _ <- char c
    (char '\\' >> return (Piece PieceRaw [c])) <|> (do
        inside <- parseCurlyBrackets
        return $ Piece PieceVar inside) <|>
            return (Piece PieceRaw [c])

parseUrl :: Char -> Char -> Parser Piece
parseUrl c d = do
    _ <- char c
    (char '\\' >> return (Piece PieceRaw [c])) <|> (do
        x <- (char d >> return True) <|> return False
        (do
            inside <- parseCurlyBrackets
            return $ Piece (if x then PieceUrlParam else PieceUrl) inside)
                <|> return (Piece PieceRaw $ if x then [c, d] else [c]))

parseInt :: Char -> Parser Piece
parseInt c = do
    _ <- char c
    (try $ char '\\' >> char '{' >> return (Piece PieceRaw [c, '{'])) <|> (do
        inside <- parseCurlyBrackets
        return $ Piece PieceMixin inside) <|> return (Piece PieceRaw [c])

parsePiece :: ShakespeareSettings -> Parser Piece
parsePiece ShakespeareSettings {..} =
    let parseVar' = parseVar varChar
        parseUrl' = parseUrl urlChar '?'
        parseInt' = parseInt intChar
        parseChar' =
            Piece PieceRaw `fmap` many1 (noneOf [varChar, urlChar, intChar])
    in  parseVar' <|> parseUrl' <|> parseInt' <|> parseChar'

scramble :: Piece -> String
scramble (Piece PieceRaw s) = s
scramble (Piece t        s) = concat
    [ "q_shakespeare_sass_"
    , case t of
        PieceRaw      -> error "Raw pieces don't need encoding"
        PieceVar      -> "var"
        PieceUrl      -> "url"
        PieceUrlParam -> "purl"
        PieceMixin    -> "mix"
    , "_"
    , BC.unpack $ B16.encode $ BU.fromString s
    , "_"
    ]

inputSettings :: ShakespeareSettings
inputSettings = defaultShakespeareSettings { varChar = '%' }

-- | Take the source SASS, possibly containing splices, and encode any splices
-- it contains from shakepeare syntax to an encoded form the SASS compiler
-- doesn't mind and doesn't touch. Return the resulting string and whether any
-- splices were found in it.
mangle :: String -> (String, Bool)
mangle s =
    case parse' (many1 $ parsePiece inputSettings) s s of
        Left e -> error $ "sass preprocessing hack parser failed: " ++ show e
        Right ps ->
            let isSplicePiece (Piece PieceRaw _) = False
                isSplicePiece _                  = True
            in (concatMap scramble ps, any isSplicePiece ps)

parseSplice :: Parser Piece
parseSplice = do
    string "q_shakespeare_sass_"
    t <-
        PieceVar      <$ string "var"  <|>
        PieceUrl      <$ string "url"  <|>
        PieceUrlParam <$ string "purl" <|>
        PieceMixin    <$ string "mix"
    char '_'
    (b, r) <- B16.decode . BC.pack <$> many1 hexDigit
    if BC.null r
        then do
            char '_'
            return $ Piece t $ BU.toString b
        else fail "failed to parse hex digits of encoded splice"

parseRaw :: Parser Piece
parseRaw = do
    c <- anyChar
    s <- many $ noneOf "q"
    return $ Piece PieceRaw $ c : s

parseEncodedPiece :: Parser Piece
parseEncodedPiece = try parseSplice <|> parseRaw

render :: ShakespeareSettings -> Piece -> String
render _  (Piece PieceRaw s)      = s
render ss (Piece PieceVar s)      = varChar ss : '{' : s ++ "}"
render ss (Piece PieceUrl s)      = urlChar ss : '{' : s ++ "}"
render ss (Piece PieceUrlParam s) = urlChar ss : '?' : '{' : s ++ "}"
render ss (Piece PieceMixin s)    = intChar ss : '{' : s ++ "}"

outputSettings :: ShakespeareSettings
outputSettings = defaultShakespeareSettings

-- | Take the compiled CSS and decode any encoded splices it contain back into
-- shakepeare syntax.
unmangle :: String -> String
unmangle s =
    case parse' (many1 parseEncodedPiece) s s of
        Left e -> error $ "sass postprocessing hack parser failed: " ++ show e
        Right ps -> concatMap (render outputSettings) ps

targetBaseDir :: FilePath
targetBaseDir = ".shakespeare-sass"

targetDirName :: FilePath -> FilePath
targetDirName = show . hashWith SHA1 . BC.pack

unshakeExt :: FilePath -> (Bool, String)
unshakeExt n =
    let (f, e) = splitExtension n
    in  case e of
            ".silius" -> (True, f <.> "sass")
            ".scarus" -> (True, f <.> "scss")
            _         -> (False, n)

-- | Given input and output files, check if the output needs to be generated
-- again. Currently this works by comparing the modification file of the files.
needsRebuild :: FilePath -> FilePath -> IO Bool
needsRebuild src dest = do
    e <- doesFileExist dest
    if e
        then do
            s <- getModificationTime src
            d <- getModificationTime dest
            return $ s > d
        else return True

cssFromString :: String -> Q Exp
cssFromString css = appE (conE 'CssBuilder) (stringE css)

resolveImport
    :: [String] -> FilePath -> FilePath -> IO (String, Maybe String)
resolveImport exts incPath file =
    let (dir, name) = splitFileName file
        options =
            let plain    = name
                under    = '_' : name
                underExt = map (\ e -> '_' : name ++ e) exts
                ext      = map (name ++) exts
            in  plain : under : underExt ++ ext
        maybeExists n =
            bool Nothing (Just n) <$> doesFileExist (incPath </> dir </> n)
    in  (dir,) <$> runMaybeT (asum $ map (MaybeT . maybeExists) options)

resolveImportMulti
    :: [String]
    -> [FilePath]
    -> FilePath
    -> IO (Maybe (FilePath, String, String))
resolveImportMulti exts incPaths file =
    let extend path (dir, mname) = (path, dir,) <$> mname
        maybeResolve path = extend path <$> resolveImport exts path file
    in  runMaybeT $ asum $ map (MaybeT . maybeResolve) incPaths

importExts :: [String]
importExts = [".sass", ".silius", ".scss", ".scarus", ".css"]

importer
    :: IORef [FilePath]
    -- ^ Collect here all the imports for later use, by prepending them to the
    -- existing list
    -> IORef Bool
    -- ^ Write here whether any of the imports contain splices, by checking the
    -- given import and ORing the value with the existing one
    -> [FilePath]
    -- ^ Import search paths
    -> String
    -- ^ Name of file specified in the @import
    -> String
    -- ^ Absolute path to importing file
    -> IO [SassImport]
importer imports splice incPaths file parent = do
    let incPaths' = takeDirectory parent : incPaths
    mfound <- resolveImportMulti importExts incPaths' file
    case mfound of
        Nothing -> error $ "Sass import not found: " ++ file
        Just (sourcePath, dir, sourceName) -> do
            let sourceFile = dir </> sourceName
                sourceFull = sourcePath </> sourceFile
                (shake, destName) = unshakeExt sourceName
                targetName = targetDirName sourcePath
                targetPath = targetBaseDir </> targetName
                destFile = dir </> destName
                destFull = targetPath </> destFile
            modifyIORef' imports (sourceFull :)
            (base, path) <-
                if shake
                    then do
                        let none = "/*N*/"
                            len = 5
                        nr <- needsRebuild sourceFull destFull
                        if nr
                            then do
                                raw <- readFile sourceFull
                                let (mangled, hasSplices) = mangle raw
                                    mangled' =
                                        if hasSplices
                                            then mangled
                                            else none ++ mangled
                                when hasSplices $ writeIORef splice True
                                createDirectoryIfMissing True $
                                    targetPath </> dir
                                writeFile destFull mangled'
                            else do
                                mark <- take len <$> readFile destFull
                                when (mark /= none) $ writeIORef splice True
                        return (targetPath, destFile)
                    else return (sourcePath, dir </> sourceName)
            return [SassImport (Just $ base </> path) Nothing Nothing Nothing]

compileSassFile
    :: Bool -> [FilePath] -> FilePath -> IO (String, Bool, [FilePath])
compileSassFile dev incPath fileName = do
    raw <- readFile fileName
    importsRef <- newIORef []
    spliceRef <- newIORef False
    targetBaseDirAbs <- makeAbsolute targetBaseDir
    let ext = takeExtension fileName
        isShake = ext == ".silius" || ext == ".scarus"
        mangle' s = if isShake then mangle s else (s, False)
        (mangled, splicesMain) = mangle' raw
        opts = def
            { sassOutputStyle      =
                if dev
                    then SassStyleNested
                    else SassStyleCompressed
            , sassSourceComments   = dev
            , sassIsIndentedSyntax =
                case ext of
                    ".sass"   -> True
                    ".scss"   -> False
                    ".silius" -> True
                    ".scarus" -> False
                    _         -> error $ fileName ++ ": is this sass or scss?"
            , sassInputPath        = Just fileName
            , sassImporters        =
                Just [ SassImporter 0 $ importer importsRef spliceRef incPath]
            }
    result <- compileString mangled opts
    case result of
        Left err -> do
            err' <- errorMessage err
            error err'
        Right compiled -> do
            splicesDeps <- readIORef spliceRef
            let hasSplices = splicesMain || splicesDeps
                unmangle' = if hasSplices then unmangle else id
                unmangled = unmangle' compiled
            imports <- readIORef importsRef
            return (unmangled, hasSplices, fileName : imports)

wsass' :: Bool -> [FilePath] -> FilePath -> Q Exp
wsass' dev incPath fileName = do
    (css, hasSplices, deps) <- runIO $ do
        for_ incPath $ \ path -> do
            createDirectoryIfMissing True $
                targetBaseDir </> targetDirName path
        compileSassFile dev incPath fileName
    traverse_ addDependentFile deps
    if hasSplices
        then luciusFromString css
        else cssFromString css

wfsSass :: Bool -> [FilePath] -> WidgetFileSettings
wfsSass dev sassInclude = def
    { wfsLanguages = \ hset -> defaultTemplateLanguages hset ++
        [ TemplateLanguage True "sass"   wsass wsass
        , TemplateLanguage True "scss"   wsass wsass
        , TemplateLanguage True "silius" wsass wsass
        , TemplateLanguage True "scarus" wsass wsass
        ]
    }
    where
    wsass = wsass' dev sassInclude
